www.gusucode.com > 落叶冰点万能企业网站内容管理系统 V9.1 > 落叶冰点万能企业网站内容管理系统 V9.1\code\admin\adminJob\inc\Function.asp
<% Dim Action, FoundErr, ErrMsg, ComeUrl Dim strInstallDir,InstallDir Dim Site_Sn '定义系统识别码 ComeUrl = Trim(Request.ServerVariables("HTTP_REFERER")) Action = Trim(Request("Action")) FoundErr = False ErrMsg = "" If Right(InstallDir, 1) <> "/" Then strInstallDir = InstallDir & "/" Else strInstallDir = InstallDir End If Site_Sn = Replace(Replace(LCase(Request.ServerVariables("SERVER_NAME") & InstallDir), "/", ""), ".", "") '************************************************* '函数名:gotTopic '作 用:截字符串,汉字一个算两个字符,英文算一个字符 '参 数:str ----原字符串 ' strlen ----截取长度 '返回值:截取后的字符串 '************************************************* function gotTopic(str,strlen) if isnull(str) or str="" then gotTopic="" exit function end if dim l,t,c, i str=replace(replace(replace(replace(str," "," "),""",chr(34)),">",">"),"<","<") l=len(str) t=0 for i=1 to l c=Abs(Asc(Mid(str,i,1))) if c>255 then t=t+2 else t=t+1 end if if t>=strlen then gotTopic=left(str,i) & "…" exit for else gotTopic=str end if next gotTopic=replace(replace(replace(replace(gotTopic," "," "),chr(34),"""),">",">"),"<","<") end function '************************************************* '函数名:NogotTopic '作 用:截字符串,汉字一个算两个字符,英文算一个字符,结尾没有三个点 '参 数:str ----原字符串 ' strlen ----截取长度 '返回值:截取后的字符串 '************************************************* function NogotTopic(str,strlen) if str="" then NogotTopic="" exit function end if dim l,t,c, i str=replace(replace(replace(replace(str," "," "),""",chr(34)),">",">"),"<","<") l=len(str) t=0 for i=1 to l c=Abs(Asc(Mid(str,i,1))) if c>255 then t=t+2 else t=t+1 end if if t>=strlen then NogotTopic=left(str,i) exit for else NogotTopic=str end if next NogotTopic=replace(replace(replace(replace(NogotTopic," "," "),chr(34),"""),">",">"),"<","<") end function '*********************************************** '函数名:JoinChar '作 用:向地址中加入 ? 或 & '参 数:strUrl ----网址 '返回值:加了 ? 或 & 的网址 '*********************************************** function JoinChar(strUrl) if strUrl="" then JoinChar="" exit function end if if InStr(strUrl,"?")<len(strUrl) then if InStr(strUrl,"?")>1 then if InStr(strUrl,"&")<len(strUrl) then JoinChar=strUrl & "&" else JoinChar=strUrl end if else JoinChar=strUrl & "?" end if else JoinChar=strUrl end if end function '*********************************************** '过程名:showpage '作 用:显示“上一页 下一页”等信息 '参 数:sfilename ----链接地址 ' totalnumber ----总数量 ' maxperpage ----每页数量 ' ShowTotal ----是否显示总数量 ' ShowAllPages ---是否用下拉列表显示所有页面以供跳转。有某些页面不能使用,否则会出现JS错误。 ' strUnit ----计数单位 ' CurrentPage -----现在的页数 '........................................调用页面需要定义的 ' CurrentPage=replacebadchar(request("page")) ' if CurrentPage="" then ' CurrentPage=1 ' else if not IsNumeric(CurrentPage) then ' CurrentPage=1 ' else if int(CurrentPage)<=0 then ' CurrentPage=1 ' else ' CurrentPage=replacebadchar(request("page")) ' end if ' end if ' end if ' strFileName="" ' maxperpage=10 ' rs.pagesize=MaxPerpage ' totalnumber=rs.recordcount ' if totalnumber mod maxperpage=0 then ' MaxPage= totalnumber \ MaxPerpage ' else ' MaxPage= totalnumber \ MaxPerpage+1 ' end if ' if int(CurrentPage)>int(MaxPage) then ' CurrentPage=MaxPage ' else ' CurrentPage=CurrentPage ' end if ' Rs.absolutepage=CurrentPage ' for ni=1 to MaxPerpage ' if rs.eof then exit for ' call showpage(strFileName,totalnumber,MaxPerPage,flase,true,"条") //调用语句 ' ' ' '*********************************************** sub showpage(sfilename,totalnumber,maxperpage,ShowTotal,ShowAllPages,strUnit,CurrentPage) dim n, i,strTemp,strUrl if totalnumber mod maxperpage=0 then n= totalnumber \ maxperpage else n= totalnumber \ maxperpage+1 end if strTemp= "<table align='center'><form name='showpages' method='post' action='" & sfilename & "'><tr><td>" if ShowTotal=true then strTemp=strTemp & "共 <b>" & totalnumber & "</b> " & strUnit & " " end if strUrl=JoinChar(sfilename) if CurrentPage<2 then strTemp=strTemp & "首页 上一页 " else strTemp=strTemp & "<a href='" & strUrl & "page=1'>首页</a> " strTemp=strTemp & "<a href='" & strUrl & "page=" & (CurrentPage-1) & "'>上一页</a> " end if if n-currentpage<1 then strTemp=strTemp & "下一页 尾页" else strTemp=strTemp & "<a href='" & strUrl & "page=" & (CurrentPage+1) & "'>下一页</a> " strTemp=strTemp & "<a href='" & strUrl & "page=" & n & "'>尾页</a>" end if strTemp=strTemp & " 页次:<strong><font color=red>" & CurrentPage & "</font>/" & n & "</strong>页 " strTemp=strTemp & " <b>" & maxperpage & "</b>" & strUnit & "/页" if ShowAllPages=True then strTemp=strTemp & " 转到:<select name='page' size='1' onchange='javascript:submit()'>" for i = 1 to n strTemp=strTemp & "<option value='" & i & "'" if cint(CurrentPage)=cint(i) then strTemp=strTemp & " selected " strTemp=strTemp & ">第" & i & "页</option>" next strTemp=strTemp & "</select>" end if strTemp=strTemp & "</td></tr></form></table>" response.write strTemp end sub '******************************************** '函数名:IsValidEmail '作 用:检查Email地址合法性 '参 数:email ----要检查的Email地址 '返回值:True ----Email地址合法 ' False ----Email地址不合法 '******************************************** function IsValidEmail(email) dim names, name, i, c IsValidEmail = true names = Split(email, "@") if UBound(names) <> 1 then IsValidEmail = false exit function end if for each name in names if Len(name) <= 0 then IsValidEmail = false exit function end if for i = 1 to Len(name) c = Lcase(Mid(name, i, 1)) if InStr("abcdefghijklmnopqrstuvwxyz_-.", c) <= 0 and not IsNumeric(c) then IsValidEmail = false exit function end if next if Left(name, 1) = "." or Right(name, 1) = "." then IsValidEmail = false exit function end if next if InStr(names(1), ".") <= 0 then IsValidEmail = false exit function end if i = Len(names(1)) - InStrRev(names(1), ".") if i <> 2 and i <> 3 then IsValidEmail = false exit function end if if InStr(email, "..") > 0 then IsValidEmail = false end if end function '*************************************************** '函数名:IsObjInstalled '作 用:检查组件是否已经安装 '参 数:strClassString ----组件名 '返回值:True ----已经安装 ' False ----没有安装 '*************************************************** Function IsObjInstalled(strClassString) On Error Resume Next IsObjInstalled = False Err = 0 Dim xTestObj Set xTestObj = Server.CreateObject(strClassString) If 0 = Err Then IsObjInstalled = True Set xTestObj = Nothing Err = 0 End Function '************************************************** '函数名:strLength '作 用:求字符串长度。汉字算两个字符,英文算一个字符。 '参 数:str ----要求长度的字符串 '返回值:字符串长度 '************************************************** function strLength(str) ON ERROR RESUME NEXT dim WINNT_CHINESE WINNT_CHINESE = (len("中国")=2) if WINNT_CHINESE then dim l,t,c dim i l=len(str) t=l for i=1 to l c=asc(mid(str,i,1)) if c<0 then c=c+65536 if c>255 then t=t+1 end if next strLength=t else strLength=len(str) end if if err.number<>0 then err.clear end function '**************************************************** '函数名:SendMail '作 用:用Jmail组件发送邮件 '参 数:ServerAddress ----服务器地址 ' AddRecipient ----收信人地址 ' Subject ----主题 ' Body ----信件内容 ' Sender ----发信人地址 '**************************************************** function SendMail(MailServerAddress,AddRecipient,Subject,Body,Sender,MailFrom) on error resume next Dim JMail Set JMail=Server.CreateObject("JMail.SMTPMail") if err then SendMail= "<br><li>没有安装JMail组件</li>" err.clear exit function end if JMail.Logging=True JMail.Charset="gb2312" JMail.ContentType = "text/html" JMail.ServerAddress=MailServerAddress JMail.AddRecipient=AddRecipient JMail.Subject=Subject JMail.Body=MailBody JMail.Sender=Sender JMail.From = MailFrom JMail.Priority=1 JMail.Execute Set JMail=nothing if err then SendMail=err.description err.clear else SendMail="OK" end if end function '************************************************** '过程名:WriteErrMsg '作 用:显示错误提示信息 '参 数:无 '************************************************** Sub WriteErrMsg() Dim strErr strErr = strErr & "<html><head><title>错误信息</title><meta http-equiv='Content-Type' content='text/html; charset=gb2312'>" & vbCrLf strErr = strErr & "<link href='" & strInstallDir & "Admin/Admin_Style.css' rel='stylesheet' type='text/css'></head><body><br><br>" & vbCrLf strErr = strErr & "<table cellpadding=2 cellspacing=1 border=0 width=400 class='border' align=center>" & vbCrLf strErr = strErr & " <tr align='center' class='title'><td height='22'><strong>错误信息</strong></td></tr>" & vbCrLf strErr = strErr & " <tr class='tdbg'><td height='100' valign='top'><b>产生错误的可能原因:</b>" & ErrMsg & "</td></tr>" & vbCrLf strErr = strErr & " <tr align='center' class='tdbg'><td>" If ComeUrl <> "" Then strErr = strErr & "<a href='javascript:history.go(-1)'><< 返回上一页</a>" Else strErr = strErr & "<a href='javascript:window.close();'>【关闭】</a>" End If strErr = strErr & "</td></tr>" & vbCrLf strErr = strErr & "</table>" & vbCrLf strErr = strErr & "</body></html>" & vbCrLf Response.Write strErr End Sub '************************************************** '过程名:WriteSuccessMsg '作 用:显示成功提示信息 '参 数:无 '************************************************** Sub WriteSuccessMsg(SuccessMsg) Dim strSuccess strSuccess = strSuccess & "<html><head><title>成功信息</title><meta http-equiv='Content-Type' content='text/html; charset=gb2312'>" & vbCrLf strSuccess = strSuccess & "<link href='" & strInstallDir & "Admin/Admin_Style.css' rel='stylesheet' type='text/css'></head><body><br><br>" & vbCrLf strSuccess = strSuccess & "<table cellpadding=2 cellspacing=1 border=0 width=400 class='border' align=center>" & vbCrLf strSuccess = strSuccess & " <tr align='center' class='title'><td height='22'><strong>恭喜你!</strong></td></tr>" & vbCrLf strSuccess = strSuccess & " <tr class='tdbg'><td height='100' valign='top'><br>" & SuccessMsg & "</td></tr>" & vbCrLf strSuccess = strSuccess & " <tr align='center' class='tdbg'><td>" If ComeUrl <> "" Then strSuccess = strSuccess & "<a href='" & ComeUrl & "'><< 返回上一页</a>" Else strSuccess = strSuccess & "<a href='javascript:window.close();'>【关闭】</a>" End If strSuccess = strSuccess & "</td></tr>" & vbCrLf strSuccess = strSuccess & "</table>" & vbCrLf strSuccess = strSuccess & "</body></html>" & vbCrLf Response.Write strSuccess End Sub '************************************************** '函数名:ReplaceBadChar '作 用:过滤非法的SQL字符 '参 数:strChar-----要过滤的字符 '返回值:过滤后的字符 '************************************************** Public Function ReplaceBadChar(strChar) If strChar = "" Or IsNull(strChar) Then ReplaceBadChar = "" Exit Function End If Dim strBadChar, arrBadChar, tempChar, i strBadChar = "',%,^,&,?,(,),<,>,[,],{,},/,\,;,:,exists,select,update,insert,=," & Chr(34) & "," & Chr(0) & "" arrBadChar = Split(strBadChar, ",") tempChar = strChar For i = 0 To UBound(arrBadChar) tempChar = Replace(tempChar, arrBadChar(i), "") Next ReplaceBadChar = tempChar End Function '************************************************** '函数名:GetRndPassword '作 用:获取验证码 '参 数:PasswordLen-----验证码 '返回值:验证码 '************************************************** Function GetRndPassword(PasswordLen) Dim Ran, i, strPassword strPassword = "" For i = 1 To PasswordLen Randomize Ran = CInt(Rnd * 2) Randomize If Ran = 0 Then Ran = CInt(Rnd * 25) + 97 strPassword = strPassword & UCase(Chr(Ran)) ElseIf Ran = 1 Then Ran = CInt(Rnd * 9) strPassword = strPassword & Ran ElseIf Ran = 2 Then Ran = CInt(Rnd * 25) + 97 strPassword = strPassword & Chr(Ran) End If Next GetRndPassword = strPassword End Function '************************************** ' 处理 resquest.QueryString 接收的 ID '************************************** function replaceid(id) TEMPid=replacebadchar(id) if TEMPid="" then TEMPid=1 else if not IsNumeric(TEMPid) then TEMPid=1 else if int(TEMPid)<=0 then TEMPid=1 else TEMPid=replacebadchar(id) end if end if end if replaceid=TEMPid end function %> <% '****************************************** ' 获得 小类 名称 '******************************************* function smallClass(classid) temp=classid set scrs=server.CreateObject("adodb.recordset") sql="select className from j_productsmallclass where delflag=false and id="&temp&"" scrs.open sql,conn,1,1 response.Write(scrs("classname")) scrs.close set scrs=nothing end function %>